home *** CD-ROM | disk | FTP | other *** search
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' OLE2BM.BAS ver. 1.3 VB 3.0 Pro Module rev. 9/23/94 '____________________________________________________________________________ ' ' The VB 3.0 Pro code in this module provides a way to transfer bitmap data ' back and forth between a bitmap object within an OLE 2.0 control (that's ' MSOLE2.VBX, not OLECLIENT.VBX!) and a picture box on a container form such ' that the user can edit the bitmap manually in PaintBrush along the way. ' ' This capability is useful when you wish to draw certain bitmap elements ' programmatically before or after hand editing. ' ' The considerable effort required in the support procedures below is quite ' typical of the wall one hits in attempting to gain programmatic control ' over data in embedded OLE 2.0 objects under VB. Getting the data into the ' OLE2 control is relatively easy--getting it out is the hard part. ' ' If you know a simpler way to get the data out, or if you understand why some ' bitmap colors appear more muted in the OLE2 control's display than in the ' picture box, I'd love to hear from you! ' ' Version 1.3 is more robust than earlier releases because ' ' 1. The function OleFile2Picture() now buffers bitmap data read from disk in ' a huge VB long integer array rather than a in VB string, thus lifting the ' 64K limit on the bitmaps it can extract from OLE2 files. Available memory ' is now the only =realistic= limit; the absolute limit of 8 GB imposed by ' the largest array index a long integer can specify shouldn't pose much of ' a problem for the foreseeable future. The array technique banks on the ' fact that the image data in a Win 3.x DIB always starts on a dword boundary. ' 2. OleFile2Picture() makes =no= assumptions about class or object names in ' the temporary OLE2 file header. Apparently, such names may be absent. ' Instead, OleFile2Picture() simply finds the first valid embedded bitmap ' in the OLE2 file. ' 3. The tests for bitmap validity in OLEFile2Picture() have been tightened up ' since version 1.2, but I'm sure they could be more rigorous. ' ' ' Jeremy McCreary ' Cliffshade Computing ' CIS [72341,3716] '____________________________________________________________________________ Option Explicit DefInt A-Z '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Bitmap-related constants and data structures '____________________________________________________________________________ Global Const OLE_CREATE_EMBED = 0 ' Ole control .Action settings Global Const OLE_ACTIVATE = 7 Global Const OLE_SAVE_TO_FILE = 11 Global Const OLE_CHANGED = 0 ' Ole control .Updated event code Global Const SRCCOPY = &HCC0020 ' BitBlt raster op: Overwrite destination Global Const CBM_INIT = &H4& ' Init created DIB with the data passed Global Const DIB_RGB_COLORS = 0 ' DIB file color tables use RGB values Type BitmapFileHeaderType ' File header common to =all= Win 3.x .BMP files bfType As Integer ' Always contains bitmap ID string "BM" bfSize As Long ' Bitmap file size in bytes, including this header bfReserved1 As Integer ' Always null bfReserved2 As Integer ' Always null bfOffBits As Long ' Offset from =start= of this header to start of data End Type '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Data structures and variables for CVL(). '____________________________________________________________________________ Type LongType Numeric As Long End Type Type String4Type bytes As String * 4 End Type Dim LongInt As LongType ' Declare at module level for speed Dim LongString As String4Type '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Required Windows 3.1 API declarations in type-safe form. '____________________________________________________________________________ Declare Function BitBlt Lib "GDI" (ByVal DesthDC, ByVal DestX, ByVal DestY, ByVal DestWidth, ByVal DestHeight, ByVal SourcehDC, ByVal SourceX, ByVal SourceY, ByVal ROP As Long) Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC) Declare Function CreateDIBitmapPacked Lib "GDI" Alias "CreateDIBitmap" (ByVal hDC, lpPackedDIB As Long, ByVal InitFlag&, lpDataBits As Long, lpBitmapInfo As Long, ByVal ColorUse) Declare Function DeleteDC Lib "GDI" (ByVal hDC) Declare Function DeleteObject Lib "GDI" (ByVal hObj) Declare Function GetTempFileName Lib "Kernel" (ByVal DriveLetterAscii, ByVal PrefixName$, ByVal Unique, ByVal NameBuffer$) Declare Function SelectObject Lib "GDI" (ByVal hDC, ByVal hObject) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Convert a 4-byte hexadecimal string to a long integer using type coercion. '____________________________________________________________________________ Function CVL (bcd$) As Long LongString.bytes = bcd$ LSet LongInt = LongString ' Transfer 4 bytes between structures CVL = LongInt.Numeric ' Data now in numeric format End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Transfer an embedded bitmap object from an OLE 2.0 (MSOLE2.VBX) control to ' a VB picture box via the intermediaries of a temporary OLE file and a ' packed DIB memory structure. '____________________________________________________________________________ Sub Ole2Pic (pic As PictureBox, ole As Control) Dim f, h0, hbm, hmem, hpic, r Dim file$ file$ = TempFileName$("") ' Open a temporary OLE file f = FreeFile Open file$ For Binary As f ole.FileNumber = f ' Make its handle the save destination ole.Action = OLE_SAVE_TO_FILE ' Save the embedded data as an OLE 2.0 file Close f hbm = OLEFile2Picture(pic, file$) ' Extract the bitmap from the OLE file If hbm Then ' Copy the extracted DDB into picture box hpic = pic.hDC hmem = CreateCompatibleDC(hpic) h0 = SelectObject(hmem, hbm) ' Select the DDB into the memory DC r = BitBlt(hpic, 0, 0, CInt(pic.ScaleWidth), CInt(pic.ScaleHeight), hmem, 0, 0, SRCCOPY) r = SelectObject(hmem, h0) ' Restore the object previously selected r = DeleteObject(hbm) ' Recover system resources r = DeleteDC(hmem) pic.Refresh ' Update the screen now End If Kill file$ ' Waste the temporary OLE file End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Copy the 1st device-independent bitmap (DIB) found in a possibly compound ' OLE 2.0 file to a packed DIB memory image, create a device-dependent bitmap ' (DDB) from the packed DIB, and return the DDB handle for future reference ' if successful, 0 if not. ' ' NB: Once the DDB is created (i.e., once the packed DIB color table has been ' translated to the nearest available device-specific colors), subsequent ' display of the bitmap goes =much= faster than if displayed directly as a ' packed DIB, say with StretchDIBits(). '____________________________________________________________________________ Function OLEFile2Picture (pic As PictureBox, OLEfile$) Dim hbm, hOLE, k, valid Dim jj As Long, kk As Long Dim bfhLen As Long, buffers As Long, bytes As Long, flength As Long Dim ptr As Long, remainder As Long, start As Long Dim BitmapOffset As Long Dim buffer$ Dim bfh As BitmapFileHeaderType Const BUFFER_SIZE = 2048& * 4& ' File input buffer length must end on Const STRING_LIMIT = 65500 ' dword boundary Const MB = 16 ' Stop style MsgBox Const BitmapID$ = "BM" Const MAX_BMINFO_SIZE = 40& + 256& * 4& ' BitmapInfo header for 256-color bitmap Const MIN_BITMAP_SIZE = 14& + 40& + 16& * 4& + 2& ' Assume < 24-bit graphics bfhLen = Len(bfh) hOLE = FreeFile ' Open the source OLE file Open OLEfile$ For Binary As hOLE flength = LOF(hOLE) If flength <= MIN_BITMAP_SIZE Then ' File too small to hold a bitmap MsgBox "Sorry, your OLE2 file is too small to contain a bitmap.", MB, "OLE2 File Error" GoTo OLEFile2PictureExit End If start = 1& ' Start at 1st byte of file bytes = flength Do ' Search for 1st/next bitmap ID string buffers = bytes \ BUFFER_SIZE buffer$ = Space$(BUFFER_SIZE) Seek hOLE, start ' Set file pointer for reading start For k = 1 To buffers Get hOLE, , buffer$ ' Read a bufferfull of OLE file data ptr = InStr(buffer$, BitmapID$) ' Look for a possible bitmap file header If ptr Then Exit For Else BitmapOffset = BitmapOffset + BUFFER_SIZE Next If ptr = 0 Then ' Check the tail remainder = bytes Mod BUFFER_SIZE buffer$ = Space$(remainder) ' Now get what's left Get hOLE, , buffer$ ptr = InStr(buffer$, BitmapID$) ' Look one last time End If If ptr Then ' Check for a valid bitmap file header BitmapOffset = BitmapOffset + ptr Get hOLE, BitmapOffset, bfh ' Read the bitmap file header bytes = bfh.bfSize - bfhLen ' Calculate bitmap size valid = ((bytes > MAX_BMINFO_SIZE) And (BitmapOffset + bfhLen + bytes <= flength + 1&) And (bfh.bfOffBits <= bfhLen + MAX_BMINFO_SIZE) And (bfh.bfReserved1 * bfh.bfReserved2 = 0)) If valid Then ' Header contents look reasonable for a bitmap ReDim PackedDIB(bytes / 4&) As Long ' Initialize dynamic array for packed DIB buffer$ = Space$(BUFFER_SIZE) buffers = bytes \ BUFFER_SIZE ' Number of buffers needed to read bitmap remainder = bytes Mod BUFFER_SIZE ptr = 1& ' ptr -> 1st byte of bitmapinfo header jj = 0& ' jj -> next array element to fill Do Until ptr > bytes - remainder ' Build up a packed DIB memory image Get hOLE, , buffer$ ' a VB array, 1 bufferfull at a time For kk = 1& To BUFFER_SIZE - 3& Step 4& ' Copy buffer to array PackedDIB(jj) = CVL(Mid$(buffer$, kk, 4)) ' kk -> dword to copy jj = jj + 1& Next ptr = ptr + BUFFER_SIZE ' ptr -> next file byte to read Loop buffer$ = Space$(remainder) ' Now get what's left Get hOLE, , buffer$ kk = remainder Mod 4& ' Pad buffer to dword boundary If kk Then buffer$ = buffer$ & String$(4& - kk, 0) For kk = 1& To remainder - 3& Step 4& ' Copy buffer to array PackedDIB(jj) = CVL(Mid$(buffer$, kk, 4)) ' kk -> dword to copy jj = jj + 1& Next ptr = (bfh.bfOffBits - bfhLen) \ 4& ' Array element starting DIB data bits ' Create a device-dependent bitmap (DDB) compatible with the target ' picture box device context. hbm = CreateDIBitmapPacked(pic.hDC, PackedDIB(0), CBM_INIT, PackedDIB(ptr), PackedDIB(0), DIB_RGB_COLORS) Exit Do ' Done--extracted first valid bitmap Else ' Try again--this is no embedded bitmap header! start = BitmapOffset + Len(BitmapID$) ' Skip over bogus bitmap ID string bytes = flength - start ' Re-calculate remaining bytes End If Else ' Done--no bitmap candidates found valid = False Exit Do End If Loop While bytes > MIN_BITMAP_SIZE If Not valid Then MsgBox "Sorry, couldn't find an embedded bitmap within your temporary OLE2 file.", MB, "OLE2 File Error" End If OLEFile2PictureExit: Close hOLE ' Done with the OLE file OLEFile2Picture = hbm ' Pass back 0 if failed, DDB handle otherwise End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Embed the bitmap contained within a VB picture box in an OLE 2.0 control ' (MSOLE2.VBX) via a temporary .BMP file. ' ' NB: The OLE control =requires= the .SourceDoc file to have the extension ' "BMP" in order to embed its data as a PaintBrush object. '____________________________________________________________________________ Sub Pic2Ole (pic As PictureBox, ole As Control) Dim r Dim file$ file$ = TempFileName$("BMP") ' Get a temporary file name with .BMP ext. SavePicture pic.Image, file$ ' Save the picture box bitmap as a DIB file ole.Class = "PBrush" ' Specify creation of Pbrush bitmap object ole.SourceDoc = file$ ' Make the temporary file the data source ole.Action = OLE_CREATE_EMBED ' Embed the data as an OLE 2.0 object Kill file$ ' Waste the temporary file End Sub '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' Create a temporary file, which will live briefly in the subdirectory ' specified by the user's TEMP environment variable--with luck perhaps ' on a ram drive for speed. '____________________________________________________________________________ Function TempFileName$ (ext$) Dim r Dim file$ Const DOT = 46 ' ANSI code for period file$ = Space$(255) ' Allow plenty of room for the name r = GetTempFileName(0, "", -1, file$) ' Let Windows supply a name file$ = Trim(file$) ' Strip off any excess white space If Len(ext$) Then ' Replace the .TMP extension r = InStr(file$, ".TMP") ' Find the .TMP extension If r Then ' Replace if present If Asc(ext$) <> DOT Then r = r + 1 ' Does ext. passed include period? Mid$(file$, r) = ext$ ' Replace .TMP with new extension End If End If TempFileName$ = file$ ' Pass back the temporary file name End Function 
